perm filename CLEFS.F4[MSS,LCS]3 blob
sn#125103 filedate 1974-10-16 generic text, type T, neo UTF8
00100 C**** CLEFS, JDRAW, CENTR, LINX, UNPACK, ROFF *********
00200 SUBROUTINE CLEFS
00400 DIMENSION JCLEF(11),MCLEF(600),RCMIN(4)
00600 COMMON /STF/RSTFAC(8),RSTJC /PLTR/IPLT,RHT,DIS
00700 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
00800 DATA RCMIN/3.3,10.5,7.0,10.5/
00900 EQUIVALENCE (JD,JQ(2)),(RJD,RJQ(2)),(JE,JQ(3)),(JI,JQ(7))
01000 1 ,(RJF,RJQ(4)),(RJE,RJQ(3)),(JH,JQ(6)),(RJG,RJQ(5))
01100 1,(RJI,RJQ(7)),(NJR,RJQ(8)),(K,JCLEF(11))
01200 JE=MOD(JE,100)
01300 CC JEZ=JE
01320 CALL NOZERO(RJF)
01346 IF(RJG.EQ.0)RJG=RJF
01372 C IF P7 = 0, IT WILL EQUAL P6.
01400 IF(JA.GT.10)GO TO 9
01500 NAME='CLEF0'
01600 IF(JE.LT.10)GO TO 4
01700 RJF=RJF*.3
01800 C SIZE FACTORS FOR SPECIAL WORDS, ETC. (PPP, MF, CRESC. ETC.)
01900 RJG=RJG*.3
02000 GO TO 4
02100 9 IF(NAME.EQ.NJR)GO TO 4
02200 IF(NAME.NE.0.AND.NJR.EQ.0)GO TO 4
02300 IF(NJR.EQ.0)GO TO 8
02400 C TO PICK UP BASIC DRAW NAME FROM P10
02500 NAME=NJR
02600 GO TO 4
02700 8 TYPE 5
02800 CC ACCEPT 6,NAME
02900 5 FORMAT(' SET P10=1'/)
03000 CC6 FORMAT(A5)
03200 C LEADS TO PROPER FILE CALL
03300 4 NM=NAME+2*(JE/10)
03400 C DRAW0 HAS ITEMS 0→9; DRAW1, 10→19; ETC. TO DRAW9, 90→99
03500 JEZ=MOD(JE,10)+1
03600 CC GO TO 2
03700 CC9 NM='CLFX'
03800 2 IF(NM.EQ.JNM)GO TO 30
03900 C SET P10≠0 TO CHANGE BASIC 'DRAW' NAME.
04000 C JUMP IF ALREADY IN CORE
04100 IF(LOOKF(NM))GO TO 1111
04200 TYPE 1112,NM
04300 RETURN
04400 1112 FORMAT(1XA5,' -- NOT FOUND')
04500 1111 JNM=NM
04600 CC CALL RDDATA(NM,JCLEF,MCLEF)
04700 CC CALL IFILE(23,NM)
04800 CALL GETFI2(NM)
04900 CC READ (23)JCLEF,K,(MCLEF(L),L=1,K)
05000 CALL FASTI2(JCLEF,11)
05100 CALL FASTI2(MCLEF,K)
05200 C NEW DATA READER 6/74
05300 30 CALL CENTER(CENTR)
05400 C CHECK THE ABOVE -- FOR P5 HEIGHT CHANGE *********************
05800 C RJF IS SIZE FACTOR
05900 IF(JE.GT.3.OR.JA.NE.3)GO TO 811
06000 CC IF(JEZ.EQ.0)JEZ=1
06050 C 0=TREB, 1=BASS, 2=ALTO, 3=TENOR(ALTO SHIFTED UP)
06100 IF(RJE.LT.100)GO TO 812
06200 RSTJC=.8*RSTJC
06300 CENTR=CENTR+RCMIN(JEZ)*RSTJC
06400 C TO SET HGT. OF MINI CLEFS
06500 812 IF(JEZ.NE.4)GO TO 811
06600 CENTR=CENTR+RSTJC*14
06700 JEZ=3
06800 C ABOVE IS NOW AT TOP
06900 811 L=JCLEF(JEZ)
07000 IF(JI.NE.0)CALL ROTATE(MCLEF,L)
07100 C RJI=P9=DEGREES OF ROTATION (0-360)
07200 CALL JDRAW(MCLEF(L),RJB,CENTR,RSTJC,RJF,RJG)
07300 C 3,POS.,STF,NT# OR CLEF,ITEM#,SIZEX,SIZEY, JH=-1 TO FILL ON CRT
07400 C JH=-2 OMITS FILLER DURING PLOT
07500
07600 CC N=0
07700 CC JD=MCLEF(L)+L
07800 CC IF(MCLEF(JD).EQ.999)N=JD+1
07900 CC1 IF(N.NE.0.AND.JH.NE.-2.AND.(IPLT.OR.JH))CALL OLDFIL(MCLEF(N),
08000 CC 1 RJB,CENTR,RJF,RJG)
08100 IF((JH.EQ.-2.AND.IPLT).OR.(JH.NE.-1.AND.IPLT.GE.0))RETURN
08200 DO 3 K=L+1,MCLEF(L)+L
08300 IF(MCLEF(K).LT.200000000)GO TO 3
08400 JD=MCLEF(L)-1
08500 IF(K.GT.L+1)JD=JD-K+L+1
08600 CALL FILLMS(JD,MCLEF(K),RJB,CENTR,RJF,RJG)
08700 RETURN
08800 3 CONTINUE
08900 C FILLS ONLY WHEN PLOTING OR RJG=-1
09000 END
09100
09200 SUBROUTINE JDRAW(M,RJB,CENTR,RSTJC,RX,RY)
09300 COMMON/LL/LL
09400 DIMENSION M(1)
09500 RC=RX*RSTJC
09600 RD=RY*RSTJC
09700 DO 2 K=2,M(1)
09800 CALL UNPACK(IA,IB,M(K))
09900 CC RA=IA*RC+RJB
10000 CC RB=IB*RD+CENTR
10100 CC IF(K.EQ.I)LL=3
10200 CC2 CALL LINES(RA,RB,LL)
10300 2 CALL LINES(FLOAT(IA)*RC+RJB,FLOAT(IB)*RD+CENTR,LL)
10400 END
10500
10600 SUBROUTINE CENTER(CNTR)
10700 C TO CENTER ITEMS CREATED WITH DRAWING PROG.
10800 COMMON /STF/RSTFAC(8),RSTJC
10900 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
11000 COMMON/POSI/STF(8),JJB,POS
11100 EQUIVALENCE (RJD,RJQ(2))
11200 CNTR=POS+(2+AMOD(RJD,100.)*7)*RSTJC
11300 END
11400
11500 SUBROUTINE LINX(A,B,C,D)
11600 C SAVES SPACE FOR SINGLE LINES.
11700 CALL LINES(A,B,3)
11800 CALL LINES(C,D,2)
11900 END
12000
12100 SUBROUTINE UNPACK(M,N,I)
12200 COMMON/LL/L
12300 C L IS FOR VIS. OR INVIS. LINES.
12400 N=I
12500 L=2
12600 M=N/100000000
12700 IF(M.EQ.0)GO TO 2
12800 L=3
12900 N=N-100000000*M
13000 2 M=N/10000
13100 CC N=N-M*10000
13200 N=MOD(N,10000)
13300 IF(M.GT.1000)M=1000-M
13400 IF(N.GT.1000)N=1000-N
13500 END
13600
13700 FUNCTION ROFF(R)
13800 S=.5
13900 IF(R)S=-S
14000 ROFF=R+S
14100 RETURN
14200 END